home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-vm.el.z / tm-vm.el
Encoding:
Text File  |  1998-05-21  |  53.9 KB  |  1,524 lines
  1. ;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM
  2.  
  3. ;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
  6. ;;         Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
  7. ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
  8. ;;         Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  9. ;;         Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
  10. ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
  11. ;; Created: 1994/10/29
  12. ;; Version: $Revision: 8.12 $
  13. ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
  14.  
  15. ;; This file is part of tm (Tools for MIME).
  16.  
  17. ;; This program is free software; you can redistribute it and/or
  18. ;; modify it under the terms of the GNU General Public License as
  19. ;; published by the Free Software Foundation; either version 2, or (at
  20. ;; your option) any later version.
  21.  
  22. ;; This program is distributed in the hope that it will be useful, but
  23. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;; General Public License for more details.
  26.  
  27. ;; You should have received a copy of the GNU General Public License
  28. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  29. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30. ;; Boston, MA 02111-1307, USA.
  31.  
  32. ;;; Commentary:
  33.  
  34. ;;      Plese insert `(require 'tm-vm)' in your ~/.vm file.
  35.  
  36. ;;; Code:
  37.  
  38. (eval-when-compile
  39.   (require 'tm-mail)
  40.   (require 'vm)
  41.   (require 'vm-window))
  42.  
  43. (require 'tm-edit)
  44. (require 'tm-view)
  45. (require 'vm-reply)
  46. (require 'vm-summary)
  47. (require 'vm-menu)
  48. (require 'vm-toolbar)
  49. (require 'vm-mime)
  50.  
  51. ;;; @ Variables
  52.  
  53. ;;; @@ User customization variables
  54.  
  55. (defvar tm-vm/use-vm-bindings t
  56.   "*If t, use VM compatible keybindings in MIME Preview buffers. 
  57. Otherwise TM generic bindings for content extraction/playing are 
  58. made available.")
  59.  
  60. (defvar tm-vm/attach-to-popup-menus t
  61.   "*If t append MIME specific commands to VM's popup menus.")
  62.  
  63. (defvar tm-vm/use-original-url-button t
  64.   "*If it is t, use original URL button instead of tm's.")
  65.  
  66. (defvar tm-vm/automatic-mime-preview (or (and (boundp 'vm-display-using-mime)
  67.                           vm-display-using-mime)
  68.                      t)
  69.   "*If non-nil, automatically process and show MIME messages.")
  70.  
  71. (defvar tm-vm/strict-mime t
  72.   "*If nil, do MIME processing even if there is no MIME-Version field.")
  73.  
  74. (defvar tm-vm/use-ps-print (not (featurep 'mule))
  75.   "*Use Postscript printing (ps-print) to print MIME messages.")
  76.  
  77. (defvar tm-vm-load-hook nil
  78.   "*List of functions called after tm-vm is loaded.")
  79.  
  80. (defvar tm-vm/select-message-hook nil
  81.   "*List of functions called every time a message is selected.
  82. tm-vm uses `vm-select-message-hook', use tm-vm/select-message-hook instead.
  83. When the hooks are run current buffer is either VM folder buffer with
  84. the current message delimited by (point-min) and (point-max) or the MIME
  85. Preview buffer.")
  86.  
  87. (defvar tm-vm/forward-message-hook vm-forward-message-hook
  88.   "*List of functions called after a Mail mode buffer has been
  89. created to forward a message in message/rfc822 type format.
  90. If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
  91. hook instead of `vm-forward-message-hook'.")
  92.  
  93. (defvar tm-vm/send-digest-hook nil
  94.   "*List of functions called after a Mail mode buffer has been
  95. created to send a digest in multipart/digest type format.
  96. If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
  97. instead of `vm-send-digest-hook'.")
  98.  
  99. (defvar tm-vm/build-mime-preview-buffer-hook nil
  100.   "*List of functions called each time a MIME Preview buffer is built.
  101. These hooks are run in the MIME-Preview buffer.")
  102.  
  103. ;;; @@ System/Information variables
  104.  
  105. (defconst tm-vm/RCS-ID
  106.   "$Id: tm-vm.el,v 8.12 1997/05/12 06:34:02 figueire Exp $")
  107. (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
  108.  
  109. ; Ensure vm-menu-mail-menu gets properly defined *before* tm-vm/vm-emulation-map
  110. ; since it contains a call to vm-menu-initialize-vm-mode-menu-map
  111. (setq vm-menu-mail-menu
  112.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  113.            (list "Mail Commands"
  114.              "Mail Commands"
  115.              "---"
  116.              "---")
  117.          (list "Mail Commands"))))
  118.     (append
  119.      title
  120.      (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
  121.        ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
  122.        ["Cancel" kill-buffer t]
  123.        "----"
  124.        "Go to Field:"
  125.        "----"
  126.        ["      To:" mail-to t]
  127.        ["      Subject:" mail-subject    t]
  128.        ["      CC:" mail-cc t]
  129.        ["      BCC:" mail-bcc t]
  130.        ["      Reply-To:" mail-reply-to t]
  131.        ["      Text" mail-text t]
  132.        "----"
  133.        ["Yank Original" vm-menu-yank-original vm-reply-list]
  134.        ["Fill Yanked Message" mail-fill-yanked-message t]
  135.        ["Insert Signature"    mail-signature t]
  136.        ["Insert File..." insert-file t]
  137.        ["Insert Buffer..."    insert-buffer t])
  138.      (if tm-vm/attach-to-popup-menus
  139.      (list "----"
  140.            (cons "MIME Commands" 
  141.              (mapcar (function (lambda (item)
  142.                      (vector (nth 1 item)
  143.                          (nth 2 item)
  144.                          t)))
  145.                  mime-editor/menu-list))))
  146.      )))
  147.  
  148. (defvar tm-vm/vm-emulation-map
  149.   (let ((map (make-sparse-keymap)))
  150.     (define-key map "h" 'vm-summarize)
  151.     ;(define-key map "\M-n" 'vm-next-unread-message)
  152.     ;(define-key map "\M-p" 'vm-previous-unread-message)
  153.     (define-key map "n" 'vm-next-message)
  154.     (define-key map "p" 'vm-previous-message)
  155.     (define-key map "N" 'vm-next-message-no-skip)
  156.     (define-key map "P" 'vm-previous-message-no-skip)
  157.     ;(define-key map "\C-\M-n" 'vm-move-message-forward)
  158.     ;(define-key map "\C-\M-p" 'vm-move-message-backward)
  159.     ;(define-key map "\t" 'vm-goto-message-last-seen)
  160.     ;(define-key map "\r" 'vm-goto-message)
  161.     (define-key map "^" 'vm-goto-parent-message)
  162.     (define-key map "t" 'vm-expose-hidden-headers)
  163.     (define-key map " " 'vm-scroll-forward)
  164.     (define-key map "b" 'vm-scroll-backward)
  165.     (define-key map "\C-?" 'vm-scroll-backward)
  166.     (define-key map "d" 'vm-delete-message)
  167.     (define-key map "\C-d" 'vm-delete-message-backward)
  168.     (define-key map "u" 'vm-undelete-message)
  169.     (define-key map "U" 'vm-unread-message)
  170.     (define-key map "e" 'vm-edit-message)
  171.     ;(define-key map "a" 'vm-set-message-attributes)
  172.     ;(define-key map "j" 'vm-discard-cached-data)
  173.     ;(define-key map "k" 'vm-kill-subject)
  174.     (define-key map "f" 'vm-followup)
  175.     (define-key map "F" 'vm-followup-include-text)
  176.     (define-key map "r" 'vm-reply)
  177.     (define-key map "R" 'vm-reply-include-text)
  178.     (define-key map "\M-r" 'vm-resend-bounced-message)
  179.     (define-key map "B" 'vm-resend-message)
  180.     (define-key map "z" 'vm-forward-message)
  181.     ;(define-key map "c" 'vm-continue-composing-message)
  182.     (define-key map "@" 'vm-send-digest)
  183.     ;(define-key map "*" 'vm-burst-digest)
  184.     (define-key map "m" 'vm-mail)
  185.     (define-key map "g" 'vm-get-new-mail)
  186.     ;(define-key map "G" 'vm-sort-messages)
  187.     (define-key map "v" 'vm-visit-folder)
  188.     (define-key map "s" 'vm-save-message)
  189.     ;(define-key map "w" 'vm-save-message-sans-headers)
  190.     ;(define-key map "A" 'vm-auto-archive-messages)
  191.     (define-key map "S" 'vm-save-folder)
  192.     ;(define-key map "|" 'vm-pipe-message-to-command)
  193.     (define-key map "#" 'vm-expunge-folder)
  194.     (define-key map "q" 'vm-quit)
  195.     (define-key map "x" 'vm-quit-no-change)
  196.     (define-key map "i" 'vm-iconify-frame)
  197.     (define-key map "?" 'vm-help)
  198.     (define-key map "\C-_" 'vm-undo)
  199.     (define-key map "\C-xu" 'vm-undo)
  200.     (define-key map "!" 'shell-command)
  201.     (define-key map "<" 'vm-beginning-of-message)
  202.     (define-key map ">" 'vm-end-of-message)
  203.     ;(define-key map "\M-s" 'vm-isearch-forward)
  204.     (define-key map "=" 'vm-summarize)
  205.     (define-key map "L" 'vm-load-init-file)
  206.     ;(define-key map "l" (make-sparse-keymap))
  207.     ;(define-key map "la" 'vm-add-message-labels)
  208.     ;(define-key map "ld" 'vm-delete-message-labels)
  209.     ;(define-key map "V" (make-sparse-keymap))
  210.     ;(define-key map "VV" 'vm-visit-virtual-folder)
  211.     ;(define-key map "VC" 'vm-create-virtual-folder)
  212.     ;(define-key map "VA" 'vm-apply-virtual-folder)
  213.     ;(define-key map "VM" 'vm-toggle-virtual-mirror)
  214.     ;(define-key map "V?" 'vm-virtual-help)
  215.     ;(define-key map "M" (make-sparse-keymap))
  216.     ;(define-key map "MN" 'vm-next-command-uses-marks)
  217.     ;(define-key map "Mn" 'vm-next-command-uses-marks)
  218.     ;(define-key map "MM" 'vm-mark-message) 
  219.     ;(define-key map "MU" 'vm-unmark-message)
  220.     ;(define-key map "Mm" 'vm-mark-all-messages)
  221.     ;(define-key map "Mu" 'vm-clear-all-marks)
  222.     ;(define-key map "MC" 'vm-mark-matching-messages)
  223.     ;(define-key map "Mc" 'vm-unmark-matching-messages)
  224.     ;(define-key map "MT" 'vm-mark-thread-subtree)
  225.     ;(define-key map "Mt" 'vm-unmark-thread-subtree)
  226.     ;(define-key map "MS" 'vm-mark-messages-same-subject)
  227.     ;(define-key map "Ms" 'vm-unmark-messages-same-subject)
  228.     ;(define-key map "MA" 'vm-mark-messages-same-author)
  229.     ;(define-key map "Ma" 'vm-unmark-messages-same-author)
  230.     ;(define-key map "M?" 'vm-mark-help)
  231.     ;(define-key map "W" (make-sparse-keymap))
  232.     ;(define-key map "WW" 'vm-apply-window-configuration)
  233.     ;(define-key map "WS" 'vm-save-window-configuration)
  234.     ;(define-key map "WD" 'vm-delete-window-configuration)
  235.     ;(define-key map "W?" 'vm-window-help)
  236.     (define-key map "\C-t" 'vm-toggle-threads-display)
  237.     (define-key map "\C-x\C-s" 'vm-save-buffer)
  238.     (define-key map "\C-x\C-w" 'vm-write-file)
  239.     (define-key map "\C-x\C-q" 'vm-toggle-read-only)
  240.     ;(define-key map "%" 'vm-change-folder-type)
  241.     (define-key map "\M-C" 'vm-show-copying-restrictions)
  242.     (define-key map "\M-W" 'vm-show-no-warranty)
  243.     ;; suppress-keymap provides these, but now that we don't use
  244.     ;; suppress-keymap anymore...
  245.     (define-key map "0" 'digit-argument)
  246.     (define-key map "1" 'digit-argument)
  247.     (define-key map "2" 'digit-argument)
  248.     (define-key map "3" 'digit-argument)
  249.     (define-key map "4" 'digit-argument)
  250.     (define-key map "5" 'digit-argument)
  251.     (define-key map "6" 'digit-argument)
  252.     (define-key map "7" 'digit-argument)
  253.     (define-key map "8" 'digit-argument)
  254.     (define-key map "9" 'digit-argument)
  255.     (define-key map "-" 'negative-argument)
  256.     (if mouse-button-2
  257.     (define-key map mouse-button-2 (function tm:button-dispatcher)))
  258.     (if (vm-menu-fsfemacs-menus-p)
  259.     (progn
  260.       (vm-menu-initialize-vm-mode-menu-map)
  261.       (define-key map [menu-bar]
  262.         (lookup-key vm-mode-menu-map [rootmenu vm]))))
  263.     map)
  264.   "VM emulation keymap for MIME-Preview buffers.")
  265.  
  266. (defvar tm-vm/popup-menu 
  267.   (let (fsfmenu
  268.     (dummy (make-sparse-keymap))
  269.     (menu (append vm-menu-dispose-menu
  270.               (list "----" 
  271.                 (cons mime-viewer/menu-title
  272.                   (mapcar (function
  273.                        (lambda (item)
  274.                          (vector (nth 1 item)(nth 2 item) t)))
  275.                       mime-viewer/menu-list))))))
  276.     (if running-xemacs
  277.     menu
  278.       (vm-easy-menu-define fsfmenu (list dummy) nil menu)
  279.       fsfmenu))
  280.   "VM's popup menu + MIME specific commands")
  281.  
  282.  
  283.  
  284. (define-key vm-mode-map "Z" 'tm-vm/view-message)
  285. (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
  286. (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
  287.  
  288. ; Disable VM 6 built-in MIME handling
  289. (setq vm-display-using-mime nil
  290.       vm-send-using-mime nil)
  291.  
  292. ;;; @ MIME encoded-words
  293.  
  294. (defvar tm-vm/use-tm-patch nil
  295.   "Does not decode encoded-words in summary buffer if it is t.
  296. If you use tiny-mime patch for VM (by RIKITAKE Kenji
  297. <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  298.  
  299. (or tm-vm/use-tm-patch
  300.     (progn
  301. (defadvice vm-compile-format (around tm activate)
  302.   "MIME decoding support through TM added."
  303.   (let ((vm-display-using-mime t))
  304.     ad-do-it))
  305.  
  306. (defadvice vm-tokenized-summary-insert (around tm activate)
  307.   "MIME decoding support through TM added."
  308.   (let ((vm-display-using-mime t))
  309.     ad-do-it))
  310.  
  311. (fset 'vm-decode-mime-encoded-words-in-string 'mime-eword/decode-string)
  312. (fset 'vm-reencode-mime-encoded-words-in-string 'mime-eword/encode-string)
  313.  
  314. ))
  315.  
  316. (defun tm-vm/decode-message-header (&optional count)
  317.   "Decode MIME header of current message.
  318. Numeric prefix argument COUNT means to decode the current message plus
  319. the next COUNT-1 messages.  A negative COUNT means decode the current
  320. message and the previous COUNT-1 messages.
  321. When invoked on marked messages (via vm-next-command-uses-marks),
  322. all marked messages are affected, other messages are ignored."
  323.   (interactive "p")
  324.   (or count (setq count 1))
  325.   (vm-follow-summary-cursor)
  326.   (vm-select-folder-buffer)
  327.   (vm-check-for-killed-summary)
  328.   (vm-error-if-folder-empty)
  329.   (vm-error-if-folder-read-only)
  330.   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  331.         (realm nil)
  332.         (vlist nil)
  333.         (vbufs nil))
  334.     (save-excursion
  335.       (while mlist
  336.         (setq realm (vm-real-message-of (car mlist)))
  337.         ;; Go to real folder of this message.
  338.         ;; But maybe this message is already real message...
  339.         (set-buffer (vm-buffer-of realm))
  340.         (let ((buffer-read-only nil))
  341.           (vm-save-restriction
  342.            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
  343.            (mime/decode-message-header))
  344.           (let ((vm-message-pointer (list realm))
  345.                 (last-command nil))
  346.             (vm-discard-cached-data))
  347.           ;; Mark each virtual and real message for later summary
  348.           ;; update.
  349.           (setq vlist (cons realm (vm-virtual-messages-of realm)))
  350.           (while vlist
  351.             (vm-mark-for-summary-update (car vlist))
  352.             ;; Remember virtual and real folders related this message,
  353.             ;; for later display update.
  354.             (or (memq (vm-buffer-of (car vlist)) vbufs)
  355.                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
  356.             (setq vlist (cdr vlist)))
  357.           (if (eq vm-flush-interval t)
  358.               (vm-stuff-virtual-attributes realm)
  359.             (vm-set-modflag-of realm t)))
  360.         (setq mlist (cdr mlist)))
  361.       ;; Update mail-buffers and summaries.
  362.       (while vbufs
  363.         (set-buffer (car vbufs))
  364.         (vm-preview-current-message)
  365.         (setq vbufs (cdr vbufs))))))
  366.  
  367. (defun tm-vm/header-filter ()
  368.   "Filter headers in current buffer according to vm-visible-headers and vm-invisible-header-regexp.
  369. Current buffer is assumed to have a message-like structure."
  370.   (goto-char (point-min))
  371.   (let ((visible-headers vm-visible-headers))
  372.     (if (or vm-use-lucid-highlighting
  373.         vm-display-xfaces)
  374.     (setq visible-headers (cons "X-Face:" vm-visible-headers)))
  375.     (vm-reorder-message-headers nil
  376.                 visible-headers
  377.                 vm-invisible-header-regexp)
  378.     (mime/decode-message-header)))
  379.  
  380. (setq mime-viewer/content-header-filter-alist 
  381.       (append '((vm-mode . tm-vm/header-filter)
  382.                 (vm-virtual-mode . tm-vm/header-filter)) 
  383.               mime-viewer/content-header-filter-alist))
  384.  
  385.  
  386.  
  387. ;;; @ MIME Viewer
  388.  
  389. (setq mime-viewer/code-converter-alist 
  390.       (append
  391.        (list (cons 'vm-mode 'mime-charset/decode-buffer)
  392.          (cons 'vm-virtual-mode 'mime-charset/decode-buffer))
  393.        mime-viewer/code-converter-alist))
  394.  
  395. ;;; @@ MIME-Preview buffer management
  396.  
  397. (defvar tm-vm/system-state nil)
  398.  
  399. (defun tm-vm/system-state ()
  400.   (save-excursion
  401.     (if mime::preview/article-buffer
  402.         (set-buffer mime::preview/article-buffer)
  403.       (vm-select-folder-buffer))
  404.     tm-vm/system-state))
  405.  
  406. (defun tm-vm/build-preview-buffer ()
  407.   "Build the MIME Preview buffer for the current VM message. 
  408. Current buffer should be VM's folder buffer."
  409.  
  410.   (set (make-local-variable 'tm-vm/system-state) 'mime-viewing)
  411.   (setq vm-system-state 'reading)
  412.  
  413.   ;; Update message flags and store them in folder buffer before 
  414.   ;; entering MIME viewer
  415.   (tm-vm/update-message-status)
  416.  
  417.   ;; We need to save window configuration because we may be working 
  418.   ;; in summary window
  419.   (save-window-excursion
  420.     (save-restriction
  421.       (save-excursion
  422.     (widen)
  423.     (goto-char (vm-start-of (car vm-message-pointer)))
  424.     (forward-line)
  425.     (narrow-to-region (point)
  426.               (vm-end-of (car vm-message-pointer)))
  427.     
  428.     (let ((ml vm-message-list)
  429.           (mp vm-message-pointer))
  430.       (mime/viewer-mode nil nil nil nil nil nil)
  431.       (setq vm-mail-buffer mime::preview/article-buffer)
  432.       (setq vm-message-list ml
  433.         vm-message-pointer mp))
  434.     ;; Install VM toolbar for MIME-Preview buffer if not installed
  435.     (tm-vm/check-for-toolbar)
  436.     (if tm-vm/use-vm-bindings
  437.         (progn 
  438.           (define-key tm-vm/vm-emulation-map "\C-c" (current-local-map))
  439.           (use-local-map tm-vm/vm-emulation-map)
  440.           (vm-menu-install-menubar)
  441.           (if (and vm-use-menus
  442.                (vm-menu-support-possible-p))
  443.           (setq mode-popup-menu tm-vm/popup-menu))))
  444.  
  445.     ;; Highlight message (and display XFace if supported)
  446.     (if (or vm-highlighted-header-regexp
  447.         (and running-xemacs vm-use-lucid-highlighting))
  448.         (vm-highlight-headers))
  449.     ;; Display XFaces with VM internal support if appropriate
  450.     (if (and vm-display-xfaces
  451.          running-xemacs
  452.          (vm-multiple-frames-possible-p)
  453.          (featurep 'xface))
  454.         (let ((highlight-headers-hack-x-face-p t)
  455.           (highlight-headers-regexp nil)
  456.           (highlight-headers-citation-regexp nil)
  457.           (highlight-headers-citation-header-regexp nil))
  458.           (highlight-headers (point-min) (point-max) t)))
  459.         ;; Energize URLs and buttons
  460.     (if (and tm-vm/use-original-url-button
  461.          vm-use-menus (vm-menu-support-possible-p))
  462.         (progn (vm-energize-headers)
  463.            (vm-energize-urls)))
  464.     (run-hooks 'tm-vm/build-mime-preview-buffer-hook)
  465.     ))))
  466.  
  467. (defun tm-vm/sync-preview-buffer ()
  468.   "Ensure that the MIME preview buffer, if it exists, actually corresponds to the current message. 
  469. If no MIME Preview buffer is needed then kill it. If no
  470. MIME Preview buffer exists nothing is done."
  471.   ;; Current buffer should be message buffer when calling this function
  472.   (let* ((mbuf (current-buffer))
  473.          (pbuf (and mime::article/preview-buffer
  474.                     (get-buffer mime::article/preview-buffer))))
  475.     (if pbuf
  476.     ;; A MIME Preview buffer exists then it may need to be synch'ed
  477.     (save-excursion
  478.       (set-buffer mbuf)
  479.       (if (and tm-vm/strict-mime
  480.            (not (vm-get-header-contents (car vm-message-pointer)
  481.                         "MIME-Version:")))
  482.           (progn
  483.         (setq mime::article/preview-buffer nil
  484.               tm-vm/system-state nil)
  485.         (if pbuf (kill-buffer pbuf)))
  486.         (tm-vm/build-preview-buffer)))
  487.           ;; Return to previous frame
  488.           )))
  489.  
  490. (defun tm-vm/toggle-preview-mode ()
  491.   "Toggle automatic MIME preview on or off. 
  492. In automatic MIME Preview mode each newly selected article is MIME processed if
  493. it has MIME content without need for an explicit request from the user. This
  494. behaviour is controlled by the variable tm-vm/automatic-mime-preview."
  495.  
  496.   (interactive)
  497.   (if tm-vm/automatic-mime-preview
  498.       (progn
  499.         (tm-vm/quit-view-message)
  500.         (setq tm-vm/automatic-mime-preview nil)
  501.         (message "Automatic MIME Preview is now disabled."))
  502.     ;; Enable Automatic MIME Preview
  503.     (tm-vm/view-message)
  504.     (setq tm-vm/automatic-mime-preview t)
  505.     (message "Automatic MIME Preview is now enabled.")
  506.     ))
  507.  
  508. ;;; @@ Display functions
  509.  
  510. (defun tm-vm/update-message-status ()
  511.   "Update current message display and summary. 
  512. Remove 'unread' and 'new' flags.  The MIME Preview buffer is not displayed,
  513. tm-vm/display-preview-buffer should be called for that. This function is
  514. display-configuration safe."
  515.   (if mime::preview/article-buffer
  516.       (set-buffer mime::preview/article-buffer)
  517.     (vm-select-folder-buffer))
  518.   (if (or (and mime::article/preview-buffer
  519.            (get-buffer mime::article/preview-buffer)
  520.            (vm-get-visible-buffer-window mime::article/preview-buffer))
  521.       (vm-get-visible-buffer-window (current-buffer)))
  522.       (progn
  523.         (if (vm-new-flag (car vm-message-pointer))
  524.             (vm-set-new-flag (car vm-message-pointer) nil))
  525.         (if (vm-unread-flag (car vm-message-pointer))
  526.             (vm-set-unread-flag (car vm-message-pointer) nil))
  527.         (vm-update-summary-and-mode-line)
  528.         (tm-vm/howl-if-eom))
  529.     (vm-update-summary-and-mode-line)))
  530.  
  531. (defun tm-vm/display-preview-buffer ()
  532.   "Replace the VM message buffer with the MIME-Preview buffer if the VM message buffer is currently displayed or undisplay it if tm-vm/system-state is nil."
  533.   (let* ((mbuf (current-buffer))
  534.          (mwin (vm-get-visible-buffer-window mbuf))
  535.          (pbuf (and mime::article/preview-buffer
  536.                     (get-buffer mime::article/preview-buffer)))
  537.          (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) 
  538.     (if (and pbuf (tm-vm/system-state))
  539.         ;; display preview buffer if preview-buffer exists
  540.         (cond
  541.          ((and mwin pwin)
  542.           (vm-undisplay-buffer mbuf)
  543.           (tm-vm/update-message-status))
  544.          ((and mwin (not pwin))
  545.           (set-window-buffer mwin pbuf)
  546.           (tm-vm/update-message-status))
  547.          (pwin
  548.           (tm-vm/update-message-status))
  549.          (t
  550.           ;; don't display if neither mwin nor pwin was displayed before.
  551.           ))
  552.       ;; display folder buffer
  553.       (cond
  554.        ((and mwin pwin)
  555.         (vm-undisplay-buffer pbuf))
  556.        ((and (not mwin) pwin)
  557.         (set-window-buffer pwin mbuf))
  558.        (mwin
  559.         ;; folder buffer is already displayed.
  560.         )
  561.        (t
  562.         ;; don't display if neither mwin nor pwin was displayed before.
  563.         )))))
  564.  
  565. (defun tm-vm/preview-current-message ()
  566.   "Either preview message (view first lines only) or MIME-Preview it.
  567. The message is previewed if message previewing is enabled see vm-preview-lines.
  568. If not, MIME-Preview current message (ie. parse MIME
  569. contents and display appropriately) if it has MIME contents and
  570. tm-vm/automatic-mime-preview is non nil. Installed on vm-visit-folder-hook and
  571. vm-select-message-hook."
  572.   ;; assumed current buffer is folder buffer.
  573.   (setq tm-vm/system-state nil)
  574.   (if (get-buffer mime/output-buffer-name)
  575.       (vm-undisplay-buffer mime/output-buffer-name))
  576.   (if (and vm-message-pointer
  577.        tm-vm/automatic-mime-preview
  578.        (or (null vm-preview-lines)
  579.            (not (eq vm-system-state 'previewing))
  580.            (and (not vm-preview-read-messages)
  581.             (not (vm-new-flag (car vm-message-pointer)))
  582.             (not (vm-unread-flag (car vm-message-pointer))))))
  583.       (if (or (not tm-vm/strict-mime)
  584.               (vm-get-header-contents (car vm-message-pointer)
  585.                                       "MIME-Version:"))
  586.           ;; do MIME processing.
  587.       (progn 
  588.         (tm-vm/build-preview-buffer)
  589.         (save-excursion
  590.           (set-buffer mime::article/preview-buffer)
  591.           (run-hooks 'tm-vm/select-message-hook)))
  592.         ;; don't do MIME processing. decode header only.
  593.         (let (buffer-read-only)
  594.           (mime/decode-message-header)
  595.       (run-hooks 'tm-vm/select-message-hook))
  596.         )
  597.     ;; don't preview; do nothing.
  598.     (run-hooks 'tm-vm/select-message-hook))
  599.   (tm-vm/display-preview-buffer))
  600.  
  601. (defun tm-vm/view-message ()
  602.   "Decode and view the current VM message as a MIME encoded message. 
  603. A MIME Preview buffer using mime/viewer-mode is created.
  604. See mime/viewer-mode for more information"
  605.   (interactive)
  606.   (vm-follow-summary-cursor)
  607.   (vm-select-folder-buffer)
  608.   (vm-check-for-killed-summary)
  609.   (vm-error-if-folder-empty)
  610.   (vm-display (current-buffer) t '(tm-vm/view-message 
  611.                                    tm-vm/toggle-preview-mode)
  612.               '(tm-vm/view-message reading-message))
  613.   (let ((tm-vm/automatic-mime-preview t))
  614.     (tm-vm/preview-current-message))
  615. )
  616.  
  617. (defun tm-vm/quit-view-message ()
  618.   "Quit MIME-Viewer and go back to normal VM. 
  619. MIME Preview buffer is killed. This function is called by `mime-viewer/quit'
  620. command via `mime-viewer/quitting-method-alist'."
  621.   (if (get-buffer mime/output-buffer-name)
  622.       (vm-undisplay-buffer mime/output-buffer-name))
  623.   (vm-select-folder-buffer)
  624.   (let* ((mbuf (current-buffer))
  625.          (pbuf (and mime::article/preview-buffer
  626.                     (get-buffer mime::article/preview-buffer)))
  627.          (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
  628.     (if pbuf (kill-buffer pbuf))
  629.     (and pwin
  630.          (select-window pwin)
  631.          (switch-to-buffer mbuf)))
  632.   (setq tm-vm/system-state nil)
  633.   (vm-display (current-buffer) t (list this-command)
  634.               (list 'reading-message)))
  635.  
  636. (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
  637. (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
  638.  
  639.  
  640.  
  641.  
  642.  
  643. ;;; @@ for tm-view
  644.  
  645. ;;; based on vm-do-reply [vm-reply.el]
  646. (defun tm-vm/do-reply (buf to-all include-text)
  647.   (save-excursion
  648.     (set-buffer buf)
  649.     (let ((dir default-directory)
  650.           to cc subject in-reply-to references newsgroups)
  651.       (cond ((setq to
  652.                    (let ((reply-to (std11-field-body "Reply-To")))
  653.                      (if (vm-ignored-reply-to reply-to)
  654.                          nil
  655.                        reply-to))))
  656.             ((setq to (std11-field-body "From")))
  657.             ;; (t (error "No From: or Reply-To: header in message"))
  658.             )
  659.       (if to-all
  660.           (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc"))))
  661.                 cc (mapconcat 'identity cc ","))
  662.         )
  663.       (setq subject (std11-field-body "Subject"))
  664.       (and subject vm-reply-subject-prefix
  665.            (let ((case-fold-search t))
  666.              (not
  667.               (equal
  668.                (string-match (regexp-quote vm-reply-subject-prefix)
  669.                              subject)
  670.                0)))
  671.            (setq subject (concat vm-reply-subject-prefix subject)))
  672.       (setq in-reply-to (std11-field-body "Message-Id")
  673.             references (nconc
  674.                         (std11-field-bodies '("References" "In-Reply-To"))
  675.                         (list in-reply-to))
  676.             newsgroups (list (or (and to-all
  677.                                       (std11-field-body "Followup-To"))
  678.                                  (std11-field-body "Newsgroups"))))
  679.       (setq to (vm-parse-addresses to)
  680.             cc (vm-parse-addresses cc))
  681.       (if vm-reply-ignored-addresses
  682.           (setq to (vm-strip-ignored-addresses to)
  683.                 cc (vm-strip-ignored-addresses cc)))
  684.       (setq to (vm-delete-duplicates to nil t))
  685.       (setq cc (vm-delete-duplicates
  686.                 (append (vm-delete-duplicates cc nil t)
  687.                         to (copy-sequence to))
  688.                 t t))
  689.       (and to (setq to (mapconcat 'identity to ",\n ")))
  690.       (and cc (setq cc (mapconcat 'identity cc ",\n ")))
  691.       (and (null to) (setq to cc cc nil))
  692.       (setq references (delq nil references)
  693.             references (mapconcat 'identity references " ")
  694.             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
  695.             references (vm-delete-duplicates references)
  696.             references (if references (mapconcat 'identity references "\n\t")))
  697.       (setq newsgroups (delq nil newsgroups)
  698.             newsgroups (mapconcat 'identity newsgroups ",")
  699.             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
  700.             newsgroups (vm-delete-duplicates newsgroups)
  701.             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
  702.       (vm-mail-internal
  703.        (if to
  704.            (format "reply to %s%s"
  705.                    (std11-full-name-string
  706.                     (car (std11-parse-address-string to)))
  707.                    (if cc ", ..." "")))
  708.        to subject in-reply-to cc references newsgroups)
  709.       (setq mail-reply-buffer buf
  710.             ;; vm-system-state 'replying
  711.             default-directory dir))
  712.     (if include-text
  713.         (save-excursion
  714.           (goto-char (point-min))
  715.           (let ((case-fold-search nil))
  716.             (re-search-forward
  717.              (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
  718.           (forward-char 1)
  719.           (tm-vm/yank-content)))
  720.     (run-hooks 'vm-reply-hook)
  721.     (run-hooks 'vm-mail-mode-hook)
  722.     ))
  723.  
  724. (defun tm-vm/following-method (buf)
  725.   (tm-vm/do-reply buf 'to-all 'include-text)
  726.   )
  727.  
  728. (defun tm-vm/yank-content ()
  729.   (interactive)
  730.   (let ((this-command 'vm-yank-message))
  731.     (vm-display nil nil '(vm-yank-message)
  732.                 '(vm-yank-message composing-message))
  733.     (save-restriction
  734.       (narrow-to-region (point)(point))
  735.       (insert-buffer mail-reply-buffer)
  736.       (goto-char (point-max))
  737.       (push-mark)
  738.       (goto-char (point-min)))
  739.     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
  740.           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
  741.           (t (mail-indent-citation)))
  742.     ))
  743.  
  744. (set-alist 'mime-viewer/following-method-alist
  745.            'vm-mode
  746.            (function tm-vm/following-method))
  747. (set-alist 'mime-viewer/following-method-alist
  748.            'vm-virtual-mode
  749.            (function tm-vm/following-method))
  750.  
  751. (set-alist 'mime-viewer/quitting-method-alist
  752.            'vm-mode
  753.            'tm-vm/quit-view-message)
  754. (set-alist 'mime-viewer/quitting-method-alist
  755.            'vm-virtual-mode
  756.            'tm-vm/quit-view-message)
  757.  
  758. ;;; @@ Motion commands
  759.  
  760. (defmacro tm-vm/save-window-excursion (&rest forms)
  761.   (list 'let '((tm-vm/selected-window (selected-window)))
  762.         (list 'unwind-protect
  763.               (cons 'progn forms)
  764.               '(if (window-live-p tm-vm/selected-window)
  765.                    (select-window tm-vm/selected-window)))))
  766.  
  767. (defmacro tm-vm/save-frame-excursion (&rest forms)
  768.   (list 'let '((tm-vm/selected-frame (vm-selected-frame)))
  769.     (list 'unwind-protect
  770.           (cons 'progn forms)
  771.           '(if (frame-live-p tm-vm/selected-frame)
  772.            (vm-select-frame tm-vm/selected-frame)))))
  773.  
  774. (defadvice vm-scroll-forward (around tm-aware activate)
  775.   "Made TM-aware (handles the MIME-Preview buffer)."
  776.   (if (and 
  777.        (not (save-excursion 
  778.           (if mime::preview/article-buffer
  779.           (set-buffer mime::preview/article-buffer))
  780.           (vm-select-folder-buffer)
  781.           (eq vm-system-state 'previewing)))
  782.        (not (tm-vm/system-state)))
  783.       (progn 
  784.     ad-do-it
  785.     (tm-vm/display-preview-buffer))
  786.     (let* ((mp-changed (vm-follow-summary-cursor))
  787.        (mbuf (or (vm-select-folder-buffer) (current-buffer)))
  788.        (mwin (vm-get-buffer-window mbuf))
  789.        (pbuf (and mime::article/preview-buffer
  790.               (get-buffer mime::article/preview-buffer)))
  791.        (pwin (and pbuf (vm-get-buffer-window pbuf)))
  792.        )
  793.       (vm-check-for-killed-summary)
  794.       (vm-error-if-folder-empty)
  795.       (cond
  796.     ; A new message was selected 
  797.     ; => leave it to tm-vm/preview-current-message
  798.        (mp-changed
  799.     nil)
  800.        ((eq vm-system-state 'previewing)
  801.     (vm-display (current-buffer) t (list this-command) '(reading-message))
  802.     (vm-show-current-message)
  803.     (tm-vm/preview-current-message))
  804.     ; Preview buffer was killed
  805.        ((null pbuf)
  806.     (tm-vm/preview-current-message))
  807.     ; Preview buffer was undisplayed
  808.        ((null pwin)
  809.     (if (null mwin)
  810.         (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
  811.             (list this-command 'reading-message)))
  812.     (tm-vm/display-preview-buffer))
  813.     ; Preview buffer is displayed => scroll
  814.        (t
  815.     (tm-vm/save-window-excursion
  816.      (select-window pwin)
  817.      (set-buffer pbuf)
  818.      (if (pos-visible-in-window-p (point-max) pwin)
  819.          (if vm-auto-next-message
  820.          (vm-next-message))
  821.        ;; not at the end of message. scroll preview buffer only.
  822.        (scroll-up)
  823.        (tm-vm/howl-if-eom))
  824.      ))))
  825.     )
  826. )
  827.  
  828. (defadvice vm-scroll-backward (around tm-aware activate)
  829.   "Made TM-aware (handles the MIME-Preview buffer)."
  830.   (if (and
  831.        (not (save-excursion 
  832.           (if mime::preview/article-buffer
  833.           (set-buffer mime::preview/article-buffer))
  834.           (vm-select-folder-buffer)
  835.           (eq vm-system-state 'previewing)))     
  836.        (not (tm-vm/system-state)))
  837.       ad-do-it
  838.     (let* ((mp-changed (vm-follow-summary-cursor))
  839.        (mbuf (or (vm-select-folder-buffer) (current-buffer)))
  840.        (mwin (vm-get-buffer-window mbuf))
  841.        (pbuf (and mime::article/preview-buffer
  842.               (get-buffer mime::article/preview-buffer)))
  843.        (pwin (and pbuf (vm-get-buffer-window pbuf)))
  844.        )
  845.       (vm-check-for-killed-summary)
  846.       (vm-error-if-folder-empty)
  847.       (cond
  848.     ; A new message was selected 
  849.     ; => leave it to tm-vm/preview-current-message
  850.        (mp-changed
  851.     nil)
  852.        ((eq vm-system-state 'previewing)
  853.     (tm-vm/update-message-status)
  854.     (setq vm-system-state 'reading)
  855.     (tm-vm/preview-current-message))
  856.     ; Preview buffer was killed
  857.        ((null pbuf)
  858.     (tm-vm/preview-current-message))
  859.     ; Preview buffer was undisplayed
  860.        ((null pwin)
  861.     (if (null mwin)
  862.         (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
  863.             (list this-command 'reading-message)))
  864.     (tm-vm/display-preview-buffer))
  865.     ; Preview buffer is displayed => scroll
  866.        (t
  867.     (tm-vm/save-window-excursion
  868.      (select-window pwin)
  869.      (if (pos-visible-in-window-p (point-min) pwin)
  870.          nil
  871.        ;; not at the end of message. scroll preview buffer only.
  872.        (scroll-down))
  873.      ))))
  874.     ))
  875.  
  876. (defadvice vm-beginning-of-message (around tm-aware activate)
  877.   "Made TM-aware, works properly in MIME-Preview buffers."
  878.   (if (not (tm-vm/system-state))
  879.       ad-do-it
  880.     (vm-follow-summary-cursor)
  881.     (vm-select-folder-buffer)
  882.     (vm-check-for-killed-summary)
  883.     (vm-error-if-folder-empty)
  884.     (let ((pbuf (and mime::article/preview-buffer
  885.                      (get-buffer mime::article/preview-buffer))))
  886.       (if (null pbuf)
  887.           (progn
  888.             (tm-vm/preview-current-message)
  889.             (setq pbuf (get-buffer mime::article/preview-buffer))
  890.             ))
  891.       (vm-display (current-buffer) t '(vm-beginning-of-message)
  892.                   '(vm-beginning-of-message reading-message))
  893.       (tm-vm/display-preview-buffer)
  894.       (tm-vm/save-window-excursion
  895.        (select-window (vm-get-visible-buffer-window pbuf))
  896.        (push-mark)
  897.        (goto-char (point-min))
  898.        (vm-display (current-buffer) t '(vm-beginning-of-message)
  899.            '(vm-beginning-of-message reading-message))
  900.        ))))
  901.  
  902. (defadvice vm-end-of-message (around tm-aware activate)
  903.   "Made TM-aware, works properly in MIME-Preview buffers."
  904.   (interactive)
  905.   (if (not (tm-vm/system-state))
  906.       ad-do-it
  907.     (vm-follow-summary-cursor)
  908.     (vm-select-folder-buffer)
  909.     (vm-check-for-killed-summary)
  910.     (vm-error-if-folder-empty)
  911.     (let ((pbuf (and mime::article/preview-buffer
  912.                      (get-buffer mime::article/preview-buffer))))
  913.       (if (null pbuf)
  914.           (progn
  915.             (tm-vm/preview-current-message)
  916.             (setq pbuf (get-buffer mime::article/preview-buffer))
  917.             ))
  918.       (vm-display (current-buffer) t '(vm-end-of-message)
  919.                   '(vm-end-of-message reading-message))
  920.       (tm-vm/display-preview-buffer)
  921.       (tm-vm/save-window-excursion
  922.        (select-window (vm-get-buffer-window pbuf))
  923.        (push-mark)
  924.        (goto-char (point-max))
  925.        (vm-display (current-buffer) t '(vm-end-of-message)
  926.            '(vm-end-of-message reading-message))
  927.        ))))
  928.  
  929. ;;; based on vm-howl-if-eom [vm-page.el]
  930. (defun tm-vm/howl-if-eom ()
  931.   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
  932.          (pwin (and (vm-get-visible-buffer-window pbuf))))
  933.     (and pwin
  934.          (save-excursion
  935.            (save-window-excursion
  936.              (condition-case ()
  937.                  (let ((next-screen-context-lines 0))
  938.                    (tm-vm/save-frame-excursion
  939.             (vm-select-frame (vm-window-frame pwin))
  940.             (save-selected-window
  941.               (select-window pwin)
  942.               (save-excursion
  943.             (let ((scroll-in-place-replace-original nil))
  944.               (scroll-up)))))
  945.             nil)
  946.                (error t))))
  947.          (vm-emit-eom-blurb)
  948.          )))
  949.  
  950. (defadvice vm-emit-eom-blurb (around tm-aware activate)
  951.   "Made TM-aware, works properly in MIME-Preview buffers."
  952.   (save-excursion
  953.     (if mime::preview/article-buffer
  954.         (set-buffer mime::preview/article-buffer))
  955.     ad-do-it))
  956.  
  957. (defadvice vm-next-message (around tm-aware activate)
  958.   "Made TM-aware, works properly in MIME-Preview buffers."
  959.   (if mime::preview/article-buffer
  960.       (set-buffer mime::preview/article-buffer))
  961.   (tm-vm/save-window-excursion
  962.    ad-do-it))
  963.  
  964. (defadvice vm-previous-message (around tm-aware activate)
  965.   "Made TM-aware, works properly in MIME-Preview buffers."
  966.   (if mime::preview/article-buffer
  967.       (set-buffer mime::preview/article-buffer))
  968.   (tm-vm/save-window-excursion
  969.    ad-do-it))
  970.  
  971. (defadvice vm-next-message-no-skip (around tm-aware activate)
  972.   "Made TM-aware, works properly in MIME-Preview buffers."
  973.   (if mime::preview/article-buffer
  974.       (set-buffer mime::preview/article-buffer))
  975.   (tm-vm/save-window-excursion
  976.    ad-do-it))
  977.  
  978. (defadvice vm-previous-message-no-skip (around tm-aware activate)
  979.   "TM wrapper for vm-previous-message-no-skip (which see)."
  980.   (if mime::preview/article-buffer
  981.       (set-buffer mime::preview/article-buffer))
  982.   (tm-vm/save-window-excursion
  983.      ad-do-it))
  984.  
  985. (defadvice vm-next-unread-message (around tm-aware activate)
  986.   "Made TM-aware, works properly in MIME-Preview buffers."
  987.   (if mime::preview/article-buffer
  988.       (set-buffer mime::preview/article-buffer))
  989.   (tm-vm/save-window-excursion
  990.    ad-do-it))
  991.  
  992. (defadvice vm-previous-unread-message (around tm-aware activate)
  993.   "Made TM-aware, works properly in MIME-Preview buffers."
  994.   (if mime::preview/article-buffer
  995.       (set-buffer mime::preview/article-buffer))
  996.   (tm-vm/save-window-excursion
  997.    ad-do-it))
  998.  
  999.  
  1000. (set-alist 'mime-viewer/over-to-previous-method-alist
  1001.            'vm-mode 'vm-previous-message)
  1002. (set-alist 'mime-viewer/over-to-next-method-alist
  1003.            'vm-mode 'vm-next-message)
  1004. (set-alist 'mime-viewer/over-to-previous-method-alist
  1005.            'vm-virtual-mode 'vm-previous-message)
  1006. (set-alist 'mime-viewer/over-to-next-method-alist
  1007.            'vm-virtual-mode 'vm-next-message)
  1008.  
  1009.  
  1010.  
  1011.  
  1012.  
  1013.  
  1014. ;;; @ MIME Editor
  1015.  
  1016. ;;; @@ vm-yank-message
  1017.  
  1018.  
  1019. (defvar tm-vm/yank:message-to-restore nil
  1020.   "For internal use by tm-vm only.")
  1021.  
  1022. (defun vm-yank-message (&optional message)
  1023.   "Yank message number N into the current buffer at point.
  1024. When called interactively N is always read from the minibuffer.  When
  1025. called non-interactively the first argument is expected to be a
  1026. message struct.
  1027.  
  1028. This function originally provided by vm-reply has been patched for TM
  1029. in order to provide better citation of MIME messages : if a MIME
  1030. Preview buffer exists for the message then its contents are inserted
  1031. instead of the raw message.
  1032.  
  1033. This command is meant to be used in VM created Mail mode buffers; the
  1034. yanked message comes from the mail buffer containing the message you
  1035. are replying to, forwarding, or invoked VM's mail command from.
  1036.  
  1037. All message headers are yanked along with the text.  Point is
  1038. left before the inserted text, the mark after.  Any hook
  1039. functions bound to mail-citation-hook are run, after inserting
  1040. the text and setting point and mark.  For backward compatibility,
  1041. if mail-citation-hook is set to nil, `mail-yank-hooks' is run
  1042. instead.
  1043.  
  1044. If mail-citation-hook and mail-yank-hooks are both nil, this
  1045. default action is taken: the yanked headers are trimmed as
  1046. specified by vm-included-text-headers and
  1047. vm-included-text-discard-header-regexp, and the value of
  1048. vm-included-text-prefix is prepended to every yanked line."
  1049.   (interactive
  1050.    (list
  1051.     ;; What we really want for the first argument is a message struct,
  1052.     ;; but if called interactively, we let the user type in a message
  1053.     ;; number instead.
  1054.     (let (mp default
  1055.              (result 0)
  1056.              prompt
  1057.              (last-command last-command)
  1058.              (this-command this-command))
  1059.       (if (bufferp vm-mail-buffer)
  1060.           (save-excursion
  1061.             (vm-select-folder-buffer)
  1062.             (setq default (and vm-message-pointer
  1063.                                (vm-number-of (car vm-message-pointer)))
  1064.                   prompt (if default
  1065.                              (format "Yank message number: (default %s) "
  1066.                                      default)
  1067.                            "Yank message number: "))
  1068.             (while (zerop result)
  1069.               (setq result (read-string prompt))
  1070.               (and (string= result "") default (setq result default))
  1071.               (setq result (string-to-int result)))
  1072.             (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  1073.                 (error "No such message."))
  1074.             (setq tm-vm/yank:message-to-restore (string-to-int default))
  1075.             (save-selected-window
  1076.               (vm-goto-message result))
  1077.             (car mp))
  1078.         nil))))
  1079.   (if (null message)
  1080.       (if mail-reply-buffer
  1081.           (tm-vm/yank-content)
  1082.         (error "This is not a VM Mail mode buffer."))
  1083.     (if (null (buffer-name vm-mail-buffer))
  1084.         (error "The folder buffer containing message %d has been killed."
  1085.                (vm-number-of message)))
  1086.     (vm-display nil nil '(vm-yank-message)
  1087.                 '(vm-yank-message composing-message))
  1088.     (let ((b (current-buffer)) (start (point)) end)
  1089.       (save-restriction
  1090.         (widen)
  1091.         (save-excursion
  1092.           (set-buffer (vm-buffer-of message))
  1093.           (let (pbuf)
  1094.             (tm-vm/sync-preview-buffer)
  1095.             (setq pbuf (and mime::article/preview-buffer
  1096.                             (get-buffer mime::article/preview-buffer)))
  1097.             (if (and pbuf
  1098.              (not (eq this-command 'vm-forward-message)))
  1099.         ;; Yank contents of MIME Preview buffer
  1100.                 (if running-xemacs
  1101.                     (let ((tmp (generate-new-buffer "tm-vm/tmp")))
  1102.                       (set-buffer pbuf)
  1103.                       (append-to-buffer tmp (point-min) (point-max))
  1104.                       (set-buffer tmp)
  1105.                       (map-extents
  1106.                        '(lambda (ext maparg) 
  1107.                           (set-extent-property ext 'begin-glyph nil)))
  1108.                       (append-to-buffer b (point-min) (point-max))
  1109.                       (setq end (vm-marker
  1110.                                  (+ start (length (buffer-string))) b))
  1111.                       (kill-buffer tmp))
  1112.                   (set-buffer pbuf)
  1113.                   (append-to-buffer b (point-min) (point-max))
  1114.                   (setq end (vm-marker
  1115.                              (+ start (length (buffer-string))) b)))
  1116.           ;; Yank contents of raw VM message
  1117.               (save-restriction
  1118.                 (setq message (vm-real-message-of message))
  1119.                 (set-buffer (vm-buffer-of message))
  1120.                 (widen)
  1121.                 (append-to-buffer
  1122.                  b (vm-headers-of message) (vm-text-end-of message))
  1123.                 (setq end
  1124.                       (vm-marker (+ start (- (vm-text-end-of message)
  1125.                                              (vm-headers-of message))) b))))))
  1126.         (push-mark end)
  1127.         (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
  1128.               (mail-yank-hooks (run-hooks 'mail-yank-hooks))
  1129.               (t (vm-mail-yank-default message)))
  1130.         ))
  1131.     (if tm-vm/yank:message-to-restore
  1132.         (save-selected-window
  1133.           (vm-goto-message tm-vm/yank:message-to-restore)
  1134.           (setq tm-vm/yank:message-to-restore nil)))
  1135.     ))
  1136.  
  1137. ;;; @@ for tm-partial
  1138. ;;;
  1139.  
  1140. (call-after-loaded
  1141.  'tm-partial
  1142.  (function
  1143.   (lambda ()
  1144.     (set-atype 'mime/content-decoding-condition
  1145.                '((type . "message/partial")
  1146.                  (method . mime-article/grab-message/partials)
  1147.                  (major-mode . vm-mode)
  1148.                  (summary-buffer-exp . vm-summary-buffer)
  1149.                  ))
  1150.     (set-alist 'tm-partial/preview-article-method-alist
  1151.                'vm-mode
  1152.                (function
  1153.                 (lambda ()
  1154.                   (tm-vm/view-message)
  1155.                   )))
  1156.     )))
  1157.  
  1158.  
  1159. ;;; @@ for tm-edit
  1160. ;;;
  1161.  
  1162. (call-after-loaded
  1163.  'mime-setup
  1164.  (function
  1165.   (lambda ()
  1166.     (setq vm-forwarding-digest-type "rfc1521")
  1167.     (setq vm-digest-send-type "rfc1521")
  1168.     )))
  1169.  
  1170. ;;; @@@ multipart/digest
  1171.  
  1172. (if (not (fboundp 'vm-unsaved-message))
  1173.     (fset 'vm-unsaved-message 'message))
  1174.  
  1175. (defun tm-vm/enclose-messages (mlist &optional preamble)
  1176.   "Enclose the messages in MLIST as multipart/digest.
  1177. The resulting digest is inserted at point in the current buffer.
  1178.  
  1179. MLIST should be a list of message structs (real or virtual).
  1180. These are the messages that will be enclosed."
  1181.   (if mlist
  1182.       (let ((digest (consp (cdr mlist)))
  1183.             (mp mlist)
  1184.             m)
  1185.         (save-restriction
  1186.           (narrow-to-region (point) (point))
  1187.           (while mlist
  1188.             (setq m (vm-real-message-of (car mlist)))
  1189.             (mime-editor/insert-tag "message" "rfc822")
  1190.             (tm-mail/insert-message m)
  1191.             (goto-char (point-max))
  1192.             (setq mlist (cdr mlist)))
  1193.           (if preamble
  1194.               (progn
  1195.                 (goto-char (point-min))
  1196.                 (mime-editor/insert-tag "text" "plain")
  1197.                 (vm-unsaved-message "Building digest preamble...")
  1198.                 (while mp
  1199.                   (let ((vm-summary-uninteresting-senders nil))
  1200.                     (insert
  1201.                      (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
  1202.                   (if vm-digest-center-preamble
  1203.                       (progn
  1204.                         (forward-char -1)
  1205.                         (center-line)
  1206.                         (forward-char 1)))
  1207.                   (setq mp (cdr mp)))))
  1208.           (if digest
  1209.               (mime-editor/enclose-digest-region (point-min) (point-max)))
  1210.           ))))
  1211.  
  1212. (defadvice vm-forward-message (around tm-aware activate)
  1213.   "Extended to support rfc1521 digests (roughly equivalent to what
  1214. VM does when vm-forwarding-digest-type is 'mime but using message/rfc822
  1215. when appropriate."
  1216.   (if (not (equal vm-forwarding-digest-type "rfc1521"))
  1217.       ad-do-it
  1218.     (if mime::preview/article-buffer
  1219.     (set-buffer mime::preview/article-buffer))
  1220.     (vm-follow-summary-cursor)
  1221.     (vm-select-folder-buffer)
  1222.     (vm-check-for-killed-summary)
  1223.     (vm-error-if-folder-empty)
  1224.     (if (eq last-command 'vm-next-command-uses-marks)
  1225.         (let ((vm-digest-send-type vm-forwarding-digest-type))
  1226.           (setq this-command 'vm-next-command-uses-marks)
  1227.           (command-execute 'tm-vm/send-digest))
  1228.       (let ((dir default-directory)
  1229.             (mp vm-message-pointer))
  1230.         (save-restriction
  1231.           (widen)
  1232.           (vm-mail-internal
  1233.            (format "forward of %s's note re: %s"
  1234.                    (vm-su-full-name (car vm-message-pointer))
  1235.                    (vm-su-subject (car vm-message-pointer)))
  1236.            nil
  1237.            (and vm-forwarding-subject-format
  1238.                 (let ((vm-summary-uninteresting-senders nil))
  1239.                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
  1240.           (make-local-variable 'vm-forward-list)
  1241.           (setq vm-system-state 'forwarding
  1242.                 vm-forward-list (list (car mp))
  1243.                 default-directory dir)
  1244.           (goto-char (point-min))
  1245.           (re-search-forward
  1246.            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
  1247.           (tm-vm/enclose-messages vm-forward-list)
  1248.           (mail-position-on-field "To"))
  1249.         (run-hooks 'tm-vm/forward-message-hook)
  1250.         (run-hooks 'vm-mail-mode-hook)))))
  1251.  
  1252. (defun tm-vm/send-digest (&optional arg)
  1253.   "Send a digest of all messages in the current folder to recipients.
  1254. The type of the digest is specified by the variable vm-digest-send-type.
  1255. You will be placed in a Mail mode buffer as is usual with replies, but you
  1256. must fill in the To: and Subject: headers manually.
  1257.  
  1258. If invoked on marked messages (via vm-next-command-uses-marks),
  1259. only marked messages will be put into the digest."
  1260.   (interactive "P")
  1261.   (if (not (equal vm-digest-send-type "rfc1521"))
  1262.       (vm-send-digest arg)
  1263.     (vm-select-folder-buffer)
  1264.     (vm-check-for-killed-summary)
  1265.     (vm-error-if-folder-empty)
  1266.     (let ((dir default-directory)
  1267.           (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
  1268.                                (vm-select-marked-or-prefixed-messages 0)
  1269.                              vm-message-list)))
  1270.       (save-restriction
  1271.         (widen)
  1272.         (vm-mail-internal (format "digest from %s" (buffer-name)))
  1273.         (setq vm-system-state 'forwarding
  1274.               default-directory dir)
  1275.         (goto-char (point-min))
  1276.         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
  1277.                                    "\n"))
  1278.         (goto-char (match-end 0))
  1279.         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
  1280.         (tm-vm/enclose-messages vm-forward-list arg)
  1281.         (mail-position-on-field "To")
  1282.         (message "Building %s digest... done" vm-digest-send-type)))
  1283.     (run-hooks 'tm-vm/send-digest-hook)
  1284.     (run-hooks 'vm-mail-mode-hook)))
  1285.  
  1286. (substitute-key-definition 'vm-send-digest
  1287.                            'tm-vm/send-digest vm-mode-map)
  1288.  
  1289. ;;; @@@ Menus
  1290.  
  1291.  
  1292. (call-after-loaded
  1293.  'tm-edit
  1294.  (function
  1295.   (lambda ()
  1296.     (autoload 'tm-mail/insert-message "tm-mail")
  1297.     (set-alist 'mime-editor/message-inserter-alist
  1298.                'mail-mode (function tm-mail/insert-message))
  1299.     (set-alist 'mime-editor/split-message-sender-alist
  1300.                'mail-mode (function
  1301.                            (lambda ()
  1302.                              (interactive)
  1303.                              (funcall send-mail-function)
  1304.                              )))
  1305.     )))
  1306.  
  1307.  
  1308.  
  1309. ;;; @ VM Integration
  1310.  
  1311. (add-hook 'vm-quit-hook 'tm-vm/quit-view-message)
  1312.  
  1313. ;;; @@ Wrappers for miscellaneous VM functions
  1314.  
  1315. (defadvice vm-summarize (around tm-aware activate)
  1316.   "Made TM aware. Callable from the MIME Preview buffer."
  1317.   (if mime::preview/article-buffer
  1318.       (set-buffer mime::preview/article-buffer))
  1319.   ad-do-it
  1320.   (save-excursion
  1321.     (set-buffer vm-summary-buffer)
  1322.     (tm-vm/check-for-toolbar))
  1323.   (tm-vm/preview-current-message))
  1324.  
  1325. (defadvice vm-expose-hidden-headers (around tm-aware activate)
  1326.   "Made TM aware. Callable from the MIME Preview buffer."
  1327.   (if mime::preview/article-buffer
  1328.       (set-buffer mime::preview/article-buffer))
  1329.   (let ((visible-headers vm-visible-headers))
  1330.     (tm-vm/quit-view-message)
  1331.     ad-do-it
  1332.     (let ((vm-visible-headers visible-headers))
  1333.       (if (= (point-min) (vm-start-of (car vm-message-pointer)))
  1334.       (setq vm-visible-headers '(".*")))
  1335.       (tm-vm/preview-current-message))))
  1336.  
  1337. (if (vm-mouse-fsfemacs-mouse-p)
  1338.     (progn
  1339.       (define-key tm-vm/vm-emulation-map [mouse-3] 'ignore)
  1340.       (define-key tm-vm/vm-emulation-map [down-mouse-3] 'vm-mouse-button-3)
  1341.       (defadvice vm-mouse-button-3 (after tm-aware activate)
  1342.     "Made TM aware. Works in MIME-Preview buffers."
  1343.     (if (and 
  1344.          vm-use-menus
  1345.          (eq major-mode 'mime/viewer-mode))
  1346.         (vm-menu-popup-mode-menu event))))
  1347. )
  1348.  
  1349. (defadvice vm-save-message (around tm-aware activate)
  1350.   "Made TM aware. Callable from the MIME Preview buffer."
  1351.   (if mime::preview/article-buffer
  1352.       (save-excursion
  1353.     (set-buffer mime::preview/article-buffer)
  1354.     ad-do-it)
  1355.     ad-do-it))
  1356.  
  1357. (defadvice vm-expunge-folder (around tm-aware activate)
  1358.   "Made TM aware. Callable from the MIME Preview buffer."
  1359.   (if mime::preview/article-buffer
  1360.       (save-excursion
  1361.     (set-buffer mime::preview/article-buffer)
  1362.     ad-do-it)
  1363.     ad-do-it))
  1364.  
  1365. (defadvice vm-save-folder (around tm-aware activate)
  1366.   "Made TM aware. Callable from the MIME Preview buffer."
  1367.   (if mime::preview/article-buffer
  1368.       (save-excursion
  1369.     (set-buffer mime::preview/article-buffer)
  1370.     ad-do-it)
  1371.     ad-do-it))
  1372.  
  1373. (defadvice vm-goto-parent-message (around tm-aware activate)
  1374.   "Made TM aware. Callable from the MIME Preview buffer."
  1375.   (if mime::preview/article-buffer
  1376.       (save-excursion
  1377.     (set-buffer mime::preview/article-buffer)
  1378.     ad-do-it)
  1379.     ad-do-it))
  1380.  
  1381. (defadvice vm-delete-message (around tm-aware activate)
  1382.   "Made TM aware. Callable from the MIME Preview buffer."
  1383.   (interactive "p")
  1384.   (if (interactive-p)
  1385.       (vm-follow-summary-cursor))
  1386.   (if mime::preview/article-buffer
  1387.       (save-excursion
  1388.     (set-buffer mime::preview/article-buffer)
  1389.     ad-do-it)
  1390.     ad-do-it))
  1391.  
  1392. (defadvice vm-delete-message-backward (around tm-aware activate)
  1393.   "Made TM aware. Callable from the MIME Preview buffer."
  1394.   (interactive "p")
  1395.   (if (interactive-p)
  1396.       (vm-follow-summary-cursor))
  1397.   (if mime::preview/article-buffer
  1398.       (save-excursion
  1399.     (set-buffer mime::preview/article-buffer)
  1400.     ad-do-it)
  1401.     ad-do-it))
  1402.  
  1403. (defadvice vm-undelete-message (around tm-aware activate)
  1404.   "Made TM aware. Callable from the MIME Preview buffer."
  1405.   (interactive "p")
  1406.   (if (interactive-p)
  1407.       (vm-follow-summary-cursor))
  1408.   (if mime::preview/article-buffer
  1409.       (save-excursion
  1410.     (set-buffer mime::preview/article-buffer)
  1411.     ad-do-it)
  1412.     ad-do-it))
  1413.  
  1414. (defadvice vm-unread-message (around tm-aware activate)
  1415.   "Made TM aware. Callable from the MIME Preview buffer."
  1416.   (if mime::preview/article-buffer
  1417.       (save-excursion
  1418.     (set-buffer mime::preview/article-buffer)
  1419.     ad-do-it)
  1420.     ad-do-it))
  1421.  
  1422. (defadvice vm-edit-message (around tm-aware activate)
  1423.   "Made TM aware. Callable from the MIME Preview buffer."
  1424.   (if mime::preview/article-buffer
  1425.       (save-excursion
  1426.     (set-buffer mime::preview/article-buffer)
  1427.     ad-do-it)
  1428.     ad-do-it))
  1429.  
  1430.  
  1431.   
  1432. ;;; @@ VM Toolbar Integration
  1433.  
  1434. ;;; based on vm-toolbar-any-messages-p [vm-toolbar.el]
  1435. (defun tm-vm/check-for-toolbar ()
  1436.   "Install VM toolbar if necessary."
  1437.   (if (and running-xemacs
  1438.        vm-toolbar-specifier)
  1439.       (progn
  1440.     (if (null (specifier-instance vm-toolbar-specifier))
  1441.         (vm-toolbar-install-toolbar))
  1442.     (vm-toolbar-update-toolbar))))
  1443.  
  1444. (defun vm-toolbar-any-messages-p ()
  1445.   (save-excursion
  1446.     (if mime::preview/article-buffer
  1447.     (set-buffer mime::preview/article-buffer))
  1448.     (vm-check-for-killed-folder)
  1449.     (vm-select-folder-buffer)
  1450.     vm-message-list))
  1451.  
  1452.  
  1453. ;;; @ BBDB Integration
  1454. ;;;
  1455.  
  1456. (call-after-loaded
  1457.  'bbdb
  1458.  (function
  1459.   (lambda ()
  1460.     (require 'bbdb-vm)
  1461.     (require 'tm-bbdb)
  1462.     (defun tm-bbdb/vm-update-record (&optional offer-to-create)
  1463.       (save-excursion
  1464.     (vm-select-folder-buffer)
  1465.     (if (and (tm-vm/system-state)
  1466.          mime::article/preview-buffer
  1467.          (get-buffer mime::article/preview-buffer))
  1468.         (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p))
  1469.           (tm-bbdb/update-record offer-to-create))
  1470.       (or (bbdb/vm-update-record offer-to-create)
  1471.           (delete-windows-on (get-buffer "*BBDB*")))
  1472.       )))
  1473.     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
  1474.     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
  1475.     (add-hook 'tm-vm/select-message-hook 'tm-bbdb/vm-update-record)
  1476.     )))
  1477.  
  1478. ;;; @ ps-print (Suggested by Anders Stenman <stenman@isy.liu.se>)
  1479. ;;;
  1480.  
  1481. (if tm-vm/use-ps-print
  1482.     (progn
  1483.       (autoload 'ps-print-buffer-with-faces "ps-print" "Postscript Print" t)
  1484.       (add-hook 'vm-mode-hook 'tm-vm/ps-print-setup)
  1485.       (add-hook 'mime-viewer/define-keymap-hook 'tm-vm/ps-print-setup)
  1486.       (fset 'vm-toolbar-print-command 'tm-vm/print-message)))
  1487.  
  1488. (defun tm-vm/ps-print-setup ()
  1489.   "Set things up for printing MIME messages with ps-print. Set binding to 
  1490. the [Print Screen] key."
  1491.   (local-set-key (if running-xemacs
  1492.              'f22
  1493.            [f22]) 
  1494.          'tm-vm/print-message)
  1495.   (make-local-variable 'ps-header-lines)
  1496.   (make-local-variable 'ps-left-header)
  1497.   (setq ps-header-lines 3)
  1498.   (setq ps-left-header
  1499.         (list 'ps-article-subject 'ps-article-author 'buffer-name)))
  1500.  
  1501. (defun tm-vm/print-message ()
  1502.   "Print current message with ps-print if it's a MIME message. 
  1503. Value of tm-vm/strict-mime is also taken into consideration."
  1504.   (interactive)
  1505.   (vm-follow-summary-cursor)
  1506.   (vm-select-folder-buffer)
  1507.   (tm-vm/sync-preview-buffer)
  1508.   (let ((pbuf (and mime::article/preview-buffer
  1509.           (get-buffer mime::article/preview-buffer))))
  1510.     (if pbuf
  1511.         (save-excursion
  1512.           (set-buffer pbuf)
  1513.           (require 'ps-print)
  1514.           (ps-print-buffer-with-faces))
  1515.       (vm-print-message))))
  1516.  
  1517.  
  1518. ;;; @ end
  1519.  
  1520. (provide 'tm-vm)
  1521. (run-hooks 'tm-vm-load-hook)
  1522.  
  1523. ;;; tm-vm.el ends here.
  1524.